home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / shrink12.arc / STRPROCS.PAS < prev   
Pascal/Delphi Source File  |  1989-03-10  |  8KB  |  259 lines
  1. Unit StrProcs;
  2.  
  3. { *****  Misc. String Functions ******************************************** }
  4.  
  5. Interface
  6.  
  7. Uses Dos;
  8.  
  9. Function Upper(StrIn : String) : String;
  10. { Convert a string to upper case }
  11.  
  12. Function PathOnly(FileName : String) : String;
  13. { Strip any filename information from a file specification }
  14.  
  15. Function NameOnly(FileName : String) : String;
  16. { Strip any path information from a file specification }
  17.  
  18. Function BaseNameOnly(FileName : String) : String;
  19. { Strip any path and extension information from a file specification }
  20.  
  21. Function ExtOnly(FileName : String) : String;
  22. { Return only the extension portion of a filename }
  23.  
  24. Function IntStr(Int : LongInt; Form : Integer) : String;
  25. { Convert an Integer variable to a string }
  26.  
  27. Function SameFile(File1, File2 : String) : Boolean;
  28. { Call to find out if File1 has a name equivalent to File2.  Both filespecs }
  29. { may contain wildcards.                                                    }
  30.  
  31. { ************************************************************************** }
  32.  
  33. Implementation
  34.  
  35. Function Upper(StrIn : String) : String;
  36. Begin
  37.    Inline(                   { Thanks to Phil Burns for this routine }
  38.  
  39.       $1E/                   {         PUSH    DS                ; Save DS}
  40.       $C5/$76/$06/           {         LDS     SI,[BP+6]         ; Get source string address}
  41.       $C4/$7E/$0A/           {         LES     DI,[BP+10]        ; Get result string address}
  42.       $FC/                   {         CLD                       ; Forward direction for strings}
  43.       $AC/                   {         LODSB                     ; Get length of source string}
  44.       $AA/                   {         STOSB                     ; Copy to result string}
  45.       $30/$ED/               {         XOR     CH,CH}
  46.       $88/$C1/               {         MOV     CL,AL             ; Move string length to CL}
  47.       $E3/$0E/               {         JCXZ    Exit              ; Skip if null string}
  48.                              {;}
  49.       $AC/                   {UpCase1: LODSB                     ; Get next source character}
  50.       $3C/$61/               {         CMP     AL,'a'            ; Check if lower-case letter}
  51.       $72/$06/               {         JB      UpCase2}
  52.       $3C/$7A/               {         CMP     AL,'z'}
  53.       $77/$02/               {         JA      UpCase2}
  54.       $2C/$20/               {         SUB     AL,'a'-'A'        ; Convert to uppercase}
  55.                              {;}
  56.       $AA/                   {UpCase2: STOSB                     ; Store in result}
  57.       $E2/$F2/               {         LOOP    UpCase1}
  58.                              {;}
  59.       $1F);                  {Exit:    POP     DS                ; Restore DS}
  60.  
  61. end {Upper};
  62.  
  63. { -------------------------------------------------------------------------- }
  64.  
  65. Function PathOnly(FileName : String) : String;
  66. Var
  67.    Dir  : DirStr;
  68.    Name : NameStr;
  69.    Ext  : ExtStr;
  70. Begin
  71.    FSplit(FileName, Dir, Name, Ext);
  72.    PathOnly := Dir;
  73. End {PathOnly};
  74.  
  75. { --------------------------------------------------------------------------- }
  76.  
  77. Function NameOnly(FileName : String) : String;
  78. { Strip any path information from a file specification }
  79. Var
  80.    Dir  : DirStr;
  81.    Name : NameStr;
  82.    Ext  : ExtStr;
  83. Begin
  84.    FSplit(FileName, Dir, Name, Ext);
  85.    NameOnly := Name + Ext;
  86. End {NameOnly};
  87.  
  88. { --------------------------------------------------------------------------- }
  89.  
  90. Function BaseNameOnly(FileName : String) : String;
  91. { Strip any path and extension from a file specification }
  92. Var
  93.    Dir  : DirStr;
  94.    Name : NameStr;
  95.    Ext  : ExtStr;
  96. Begin
  97.    FSplit(FileName, Dir, Name, Ext);
  98.    BaseNameOnly := Name;
  99. End {BaseNameOnly};
  100.  
  101. { --------------------------------------------------------------------------- }
  102.  
  103. Function ExtOnly(FileName : String) : String;
  104. { Strip the path and name from a file specification.  Return only the }
  105. { filename extension.                                                 }
  106. Var
  107.    Dir  : DirStr;
  108.    Name : NameStr;
  109.    Ext  : ExtStr;
  110. Begin
  111.    FSplit(FileName, Dir, Name, Ext);
  112.    If Pos('.', Ext) <> 0 then
  113.       Delete(Ext, 1, 1);
  114.    ExtOnly := Ext;
  115. End {ExtOnly};
  116.  
  117. { --------------------------------------------------------------------------- }
  118.  
  119. Function IntStr(Int : LongInt; Form : Integer) : String;
  120. Var
  121.    S : String;
  122. Begin
  123.    If Form = 0 then
  124.       Str(Int, S)
  125.    else
  126.       Str(Int:Form, S);
  127.    IntStr := S;
  128. End {IntStr};
  129.  
  130. { --------------------------------------------------------------------------- }
  131.  
  132. Function SameName(N1, N2 : String) : Boolean;
  133. {
  134.   Function to compare filespecs.
  135.  
  136.   Wildcards allowed in either name.
  137.   Filenames should be compared seperately from filename extensions by using
  138.      seperate calls to this function
  139.         e.g.  FName1.Ex1
  140.               FName2.Ex2
  141.               are they the same?
  142.               they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)
  143.  
  144.   Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
  145.   match just any file...only those with 'XX' as the last two characters of
  146.   the name portion and 'DAT' as the extension).
  147.  
  148.   This routine calls itself recursively to resolve wildcard matches.
  149.  
  150. }
  151. Var
  152.    P1, P2 : Integer;
  153.    Match  : Boolean;
  154. Begin
  155.    P1    := 1;
  156.    P2    := 1;
  157.    Match := TRUE;
  158.  
  159.    If (Length(N1) = 0) and (Length(N2) = 0) then
  160.       Match := True
  161.    else
  162.       If Length(N1) = 0 then
  163.          If N2[1] = '*' then
  164.             Match := TRUE
  165.          else
  166.             Match := FALSE
  167.       else
  168.          If Length(N2) = 0 then
  169.             If N1[1] = '*' then
  170.                Match := TRUE
  171.             else
  172.                Match := FALSE;
  173.  
  174.    While (Match = TRUE) and (P1 <= Length(N1)) and (P2 <= Length(N2)) do
  175.       If (N1[P1] = '?') or (N2[P2] = '?') then begin
  176.          Inc(P1);
  177.          Inc(P2);
  178.       end {then}
  179.       else
  180.          If N1[P1] = '*' then begin
  181.             Inc(P1);
  182.             If P1 <= Length(N1) then begin
  183.                While (P2 <= Length(N2)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
  184.                   Inc(P2);
  185.                If P2 > Length(N2) then
  186.                   Match := FALSE
  187.                else begin
  188.                   P1 := Succ(Length(N1));
  189.                   P2 := Succ(Length(N2));
  190.                end {if};
  191.             end {then}
  192.             else
  193.                P2 := Succ(Length(N2));
  194.          end {then}
  195.          else
  196.             If N2[P2] = '*' then begin
  197.                Inc(P2);
  198.                If P2 <= Length(N2) then begin
  199.                   While (P1 <= Length(N1)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
  200.                      Inc(P1);
  201.                   If P1 > Length(N1) then
  202.                      Match := FALSE
  203.                   else begin
  204.                      P1 := Succ(Length(N1));
  205.                      P2 := Succ(Length(N2));
  206.                   end {if};
  207.                end {then}
  208.                else
  209.                   P1 := Succ(Length(N1));
  210.             end {then}
  211.             else
  212.                If UpCase(N1[P1]) = UpCase(N2[P2]) then begin
  213.                   Inc(P1);
  214.                   Inc(P2);
  215.                end {then}
  216.                else
  217.                   Match := FALSE;
  218.  
  219.    If P1 > Length(N1) then begin
  220.       While (P2 <= Length(N2)) and (N2[P2] = '*') do
  221.          Inc(P2);
  222.       If P2 <= Length(N2) then
  223.          Match := FALSE;
  224.    end {if};
  225.  
  226.    If P2 > Length(N2) then begin
  227.       While (P1 <= Length(N1)) and (N1[P1] = '*') do
  228.          Inc(P1);
  229.       If P1 <= Length(N1) then
  230.          Match := FALSE;
  231.    end {if};
  232.  
  233.    SameName := Match;
  234.  
  235. End {SameName};
  236.  
  237. { ---------------------------------------------------------------------------- }
  238.  
  239. Function SameFile(File1, File2 : String) : Boolean;
  240. Var
  241.    Path1, Path2 : String;
  242. Begin
  243.  
  244.    File1 := FExpand(File1);
  245.    File2 := FExpand(File2);
  246.    Path1 := PathOnly(File1);
  247.    Path2 := PathOnly(File2);
  248.  
  249.    SameFile := SameName(BaseNameOnly(File1), BaseNameOnly(File2)) AND
  250.                SameName(ExtOnly(File1), ExtOnly(File2))           AND
  251.                (Path1 = Path2);
  252.  
  253. End {SameFile};
  254.  
  255. { ---------------------------------------------------------------------------- }
  256.  
  257. End {Unit StrProcs}.
  258.  
  259.